home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / aijournl / 1988_12 / exptbx.cde < prev    next >
Text File  |  1988-05-04  |  6KB  |  259 lines
  1. Code to accompany Expert's Toolbox for December 1988
  2.  
  3.  
  4.  
  5. (defnode s 
  6.   (cat noun s2 
  7.     (setr subj *))) 
  8.  
  9. (defnode s2 
  10.   (cat verb s3 
  11.     (setr v *))) 
  12.  
  13. (defnode s3 
  14.   (pop `(sentence 
  15.           (subject ,(getr subj)) 
  16.           (verb ,(getr v))))) 
  17.  
  18.  
  19.  
  20. (setq paths nil) 
  21.  
  22. (defmacro choose (&rest choices) 
  23.   `(progn 
  24.      ,@(mapcar #'(lambda (c) 
  25.                    `(push #'(lambda () ,c) paths)) 
  26.                (reverse (cdr choices))) 
  27.      ,(car choices))) 
  28.  
  29. (defun fail () 
  30.   (if paths 
  31.       (funcall (pop paths)) 
  32.       'no-more-choices)) 
  33.  
  34. Listings begin here
  35.  
  36. (defun nilregs () 
  37.   `(())) 
  38.  
  39. (defmacro getr (key regs) 
  40.   `(let ((result (cdr (assq ',key (car ,regs))))) 
  41.      (if (> (length result) 1) 
  42.          result 
  43.          (car result)))) 
  44.  
  45. (defmacro setr (key val regs) 
  46.   `(cons (cons (cons ',key (list ,val)) 
  47.                (remove (assq ',key (car ,regs)) (car ,regs) :test #'equal)) 
  48.          (cdr ,regs))) 
  49.  
  50. (defmacro pushr (key val regs) 
  51.   `(cons (cons (cons ',key (cons ,val (cdr (assq ',key (car ,regs))))) 
  52.                (remove (assq ',key (car ,regs)) (car ,regs) :test #'equal)) 
  53.          (cdr ,regs))) 
  54.  
  55.  
  56.  
  57. Listing 2
  58.  
  59. (defun compile-arc (arc) 
  60.   (apply (case (car arc) 
  61.            (push #'compile-push) 
  62.            (cat  #'compile-cat) 
  63.            (jump #'compile-jump) 
  64.            (pop  #'compile-pop)) 
  65.          (cdr arc))) 
  66.  
  67. (defun compile-push (sub next &rest cmds) 
  68.   `(,sub pos 
  69.          (cons nil regs) 
  70.          #'(lambda (* newpos regs) 
  71.              (,next newpos ,(compile-cmds cmds) cont)))) 
  72.  
  73. (defun compile-cat (cat next &rest cmds) 
  74.   `(if (= (length sentence) pos) 
  75.        (fail) 
  76.        (let ((* (nth pos sentence))) 
  77.          (if (memq ',cat (types *)) 
  78.              (,next (1+ pos) ,(compile-cmds cmds) cont) 
  79.              (fail))))) 
  80.  
  81. (defun compile-jump (next &rest cmds) 
  82.   `(,next pos ,(compile-cmds cmds) cont)) 
  83.  
  84. (defun compile-cmds (cmds) 
  85.   (if (null cmds) 
  86.       'regs 
  87.       `(,@(car cmds) ,(compile-cmds (cdr cmds))))) 
  88.  
  89. Listing 3
  90.  
  91. (defun compile-pop (expr) 
  92.   `(let ((* (nth pos sentence))) 
  93.      (funcall cont ,(fix-getrs expr) pos (cdr regs)))) 
  94.  
  95. (defun fix-getrs (expr) 
  96.   (cond ((atom expr) expr) 
  97.         ((eq (car expr) 'getr) 
  98.          (append expr '(regs))) 
  99.         (t (mapcar #'fix-getrs expr)))) 
  100.  
  101.  
  102. Listing 4
  103.  
  104. (defun parse (sent) 
  105.   (setq sentence sent) 
  106.   (setq paths nil) 
  107.   (do ((retval (s 0 (nilregs) #'(lambda (expr pos regs) 
  108.                                   (list pos expr))) 
  109.                (fail))) 
  110.       ((eq retval 'no-more-choices)) 
  111.     (when (= (car retval) (length sent)) 
  112.       (terpri) 
  113.       (pprint (cadr retval))))) 
  114.  
  115.  
  116. Listing 5
  117.  
  118. (defnode s 
  119.   (push np s/subj 
  120.     (setr mood 'decl) 
  121.     (setr subj *)) 
  122.   (cat v v 
  123.     (setr mood 'imp) 
  124.     (setr subj '(np (pron you))) 
  125.     (setr aux nil) 
  126.     (setr v *))) 
  127.  
  128. (defnode s/subj 
  129.   (cat v v 
  130.     (setr aux nil) 
  131.     (setr v *))) 
  132.  
  133. (defnode pivot 
  134.   (cat v v 
  135.     (setr v *))) 
  136.  
  137. (defnode v 
  138.   (pop `(s (mood ,(getr mood)) 
  139.            (subj ,(getr subj)) 
  140.            (vcl (aux ,(getr aux)) 
  141.                 (v ,(getr v))))) 
  142.   (push np s/obj 
  143.     (setr obj *))) 
  144.  
  145. (defnode s/obj 
  146.   (pop `(s (mood ,(getr mood)) 
  147.            (subj ,(getr subj)) 
  148.            (vcl (aux ,(getr aux)) 
  149.                 (v ,(getr v))) 
  150.            (obj ,(getr obj))))) 
  151.  
  152.  
  153. Listing 6
  154.  
  155. (defnode np 
  156.   (cat det np/det 
  157.     (setr det *)) 
  158.   (jump np/det 
  159.     (setr det nil)) 
  160.   (cat pron  pron 
  161.     (setr n *))) 
  162.  
  163. (defnode pron 
  164.   (pop `(np (pronoun ,(getr n))))) 
  165.  
  166. (defnode np/det 
  167.   (push mods np/mods 
  168.     (setr mods *)) 
  169.   (jump np/mods 
  170.     (setr mods nil))) 
  171.  
  172. (defnode np/mods 
  173.   (cat n np/n 
  174.     (setr n *))) 
  175.  
  176. (defnode np/n 
  177.   (pop `(np (det ,(getr det)) 
  178.             (modifiers ,(getr mods)) 
  179.             (noun ,(getr n)))) 
  180.   (push pp/ np/pp 
  181.     (setr pp *))) 
  182.  
  183. (defnode np/pp 
  184.   (pop `(np (det ,(getr det)) 
  185.             (modifiers ,(getr mods)) 
  186.             (noun ,(getr n)) 
  187.             (pp ,(getr pp))))) 
  188.  
  189. Listing 7
  190.  
  191. (defnode pp/ 
  192.   (cat prep pp/prep 
  193.     (setr prep *))) 
  194.  
  195. (defnode pp/prep 
  196.   (push np pp/np 
  197.     (setr op *))) 
  198.  
  199. (defnode pp/np 
  200.   (pop `(pp (prep ,(getr prep)) 
  201.             (obj ,(getr op))))) 
  202.  
  203.  
  204. Listing 8
  205.  
  206. (defnode mods 
  207.   (cat n mods/n 
  208.     (setr mods *))) 
  209.  
  210. (defnode mods/n 
  211.   (cat n mods/n 
  212.     (pushr mods *)) 
  213.   (pop `(n-group ,(getr mods)))) 
  214.  
  215.  
  216.  
  217. Listing  9
  218.  
  219. (defun types (wrd) 
  220.   (case wrd 
  221.     ((do does did) '(aux v)) 
  222.     ((time times) '(n v)) 
  223.     ((fly flies) '(n v)) 
  224.     ((like) '(v prep)) 
  225.     ((liked likes) '(v)) 
  226.     ((a an the) '(det)) 
  227.     ((arrow arrows) '(n)) 
  228.     ((i you he she him her it) '(pron)))) 
  229.  
  230.  
  231. Listing 10
  232.  
  233. > (parse '(time flies like an arrow)) 
  234.  
  235.  
  236. (S (MOOD DECL) 
  237.    (SUBJ (NP (DET NIL) 
  238.              (MODIFIERS (N-GROUP TIME)) 
  239.              (NOUN FLIES))) 
  240.    (VCL (AUX NIL) 
  241.         (V LIKE)) 
  242.    (OBJ (NP (DET AN) 
  243.             (MODIFIERS NIL) 
  244.             (NOUN ARROW)))) 
  245.  
  246. (S (MOOD IMP) 
  247.    (SUBJ (NP (PRON YOU))) 
  248.    (VCL (AUX NIL) 
  249.         (V TIME)) 
  250.    (OBJ (NP (DET NIL) 
  251.             (MODIFIERS NIL) 
  252.             (NOUN FLIES) 
  253.             (PP (PREP LIKE) 
  254.                 (OBJ (NP (DET AN) 
  255.                          (MODIFIERS NIL) 
  256.                          (NOUN ARROW))))))) 
  257. NIL 
  258.             (OBJ (NP (DET AN) 
  259.